home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / pc / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / DirectInput / Joystick / frmMain.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-10-08  |  11.4 KB  |  355 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "JoyStick Sample"
  5.    ClientHeight    =   6240
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   6000
  9.    Icon            =   "frmMain.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   6240
  14.    ScaleWidth      =   6000
  15.    StartUpPosition =   3  'Windows Default
  16.    Begin VB.ListBox lstHat 
  17.       Enabled         =   0   'False
  18.       Height          =   1230
  19.       ItemData        =   "frmMain.frx":0442
  20.       Left            =   4080
  21.       List            =   "frmMain.frx":0444
  22.       TabIndex        =   6
  23.       Top             =   3240
  24.       Width           =   1695
  25.    End
  26.    Begin VB.ListBox lstButton 
  27.       Enabled         =   0   'False
  28.       Height          =   2790
  29.       ItemData        =   "frmMain.frx":0446
  30.       Left            =   2160
  31.       List            =   "frmMain.frx":0448
  32.       TabIndex        =   2
  33.       Top             =   3240
  34.       Width           =   1695
  35.    End
  36.    Begin VB.ListBox lstJoyAxis 
  37.       Enabled         =   0   'False
  38.       Height          =   2790
  39.       ItemData        =   "frmMain.frx":044A
  40.       Left            =   240
  41.       List            =   "frmMain.frx":044C
  42.       TabIndex        =   1
  43.       Top             =   3240
  44.       Width           =   1695
  45.    End
  46.    Begin VB.ListBox lstJoySticks 
  47.       Height          =   1815
  48.       ItemData        =   "frmMain.frx":044E
  49.       Left            =   240
  50.       List            =   "frmMain.frx":0450
  51.       TabIndex        =   0
  52.       Top             =   720
  53.       Width           =   5535
  54.    End
  55.    Begin VB.Label lblHats 
  56.       Caption         =   "POVs"
  57.       BeginProperty Font 
  58.          Name            =   "MS Sans Serif"
  59.          Size            =   18
  60.          Charset         =   0
  61.          Weight          =   400
  62.          Underline       =   0   'False
  63.          Italic          =   0   'False
  64.          Strikethrough   =   0   'False
  65.       EndProperty
  66.       Height          =   375
  67.       Left            =   4080
  68.       TabIndex        =   7
  69.       Top             =   2760
  70.       Width           =   1335
  71.    End
  72.    Begin VB.Label lblButtons 
  73.       Caption         =   "Buttons"
  74.       BeginProperty Font 
  75.          Name            =   "MS Sans Serif"
  76.          Size            =   18
  77.          Charset         =   0
  78.          Weight          =   400
  79.          Underline       =   0   'False
  80.          Italic          =   0   'False
  81.          Strikethrough   =   0   'False
  82.       EndProperty
  83.       Height          =   375
  84.       Left            =   2160
  85.       TabIndex        =   5
  86.       Top             =   2760
  87.       Width           =   1575
  88.    End
  89.    Begin VB.Label lblAxis 
  90.       Caption         =   "Axes"
  91.       BeginProperty Font 
  92.          Name            =   "MS Sans Serif"
  93.          Size            =   18
  94.          Charset         =   0
  95.          Weight          =   400
  96.          Underline       =   0   'False
  97.          Italic          =   0   'False
  98.          Strikethrough   =   0   'False
  99.       EndProperty
  100.       Height          =   495
  101.       Left            =   240
  102.       TabIndex        =   4
  103.       Top             =   2760
  104.       Width           =   1335
  105.    End
  106.    Begin VB.Label lblJoy 
  107.       Caption         =   "Joysticks"
  108.       BeginProperty Font 
  109.          Name            =   "MS Sans Serif"
  110.          Size            =   18
  111.          Charset         =   0
  112.          Weight          =   400
  113.          Underline       =   0   'False
  114.          Italic          =   0   'False
  115.          Strikethrough   =   0   'False
  116.       EndProperty
  117.       Height          =   375
  118.       Left            =   240
  119.       TabIndex        =   3
  120.       Top             =   120
  121.       Width           =   4215
  122.    End
  123. Attribute VB_Name = "frmMain"
  124. Attribute VB_GlobalNameSpace = False
  125. Attribute VB_Creatable = False
  126. Attribute VB_PredeclaredId = True
  127. Attribute VB_Exposed = False
  128. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  129. '  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
  130. '  File:       FrmMain.Frm
  131. '  Content:    This sample shows one way to use DirectInput with a Joystick device
  132. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  133. Option Explicit
  134. Implements DirectXEvent8
  135. Dim dx As New DirectX8
  136. Dim di As DirectInput8
  137. Dim diDev As DirectInputDevice8
  138. Dim diDevEnum As DirectInputEnumDevices8
  139. Dim EventHandle As Long
  140. Dim joyCaps As DIDEVCAPS
  141. Dim js As DIJOYSTATE
  142. Dim DiProp_Dead As DIPROPLONG
  143. Dim DiProp_Range As DIPROPRANGE
  144. Dim DiProp_Saturation As DIPROPLONG
  145. Dim AxisPresent(1 To 8) As Boolean
  146. Dim running As Boolean
  147. Sub InitDirectInput()
  148.     Set di = dx.DirectInputCreate()
  149.     Set diDevEnum = di.GetDIDevices(DI8DEVCLASS_GAMECTRL, DIEDFL_ATTACHEDONLY)
  150.     If diDevEnum.GetCount = 0 Then
  151.       MsgBox "No joystick attached."
  152.       Unload Me
  153.     End If
  154.     'Add attached joysticks to the listbox
  155.     Dim i As Integer
  156.     For i = 1 To diDevEnum.GetCount
  157.         Call lstJoySticks.AddItem(diDevEnum.GetItem(i).GetInstanceName)
  158.     Next
  159.     ' Get an event handle to associate with the device
  160.     EventHandle = dx.CreateEvent(Me)
  161.     Exit Sub
  162. Error_Out:
  163.     MsgBox "Error initializing DirectInput."
  164.     Unload Me
  165. End Sub
  166. Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)
  167. ' This is called whenever there's a change in the joystick state.
  168. ' We check the new state and update the display.
  169.     Dim i As Integer
  170.     Dim ListPos As Integer
  171.     Dim S As String
  172.     If diDev Is Nothing Then Exit Sub
  173.         
  174.     '' Get the device info
  175.     On Local Error Resume Next
  176.     diDev.GetDeviceStateJoystick js
  177.     If Err.Number = DIERR_NOTACQUIRED Or Err.Number = DIERR_INPUTLOST Then
  178.         diDev.Acquire
  179.         Exit Sub
  180.     End If
  181.     On Error GoTo err_out
  182.     ' Display axis coordinates
  183.     ListPos = 0
  184.     For i = 1 To 8
  185.         If AxisPresent(i) Then
  186.            Select Case i
  187.                Case 1
  188.                    S = "X: " & js.x
  189.                Case 2
  190.                    S = "Y: " & js.y
  191.                Case 3
  192.                    S = "Z: " & js.z
  193.                Case 4
  194.                    S = "RX: " & js.rx
  195.                Case 5
  196.                    S = "RY: " & js.ry
  197.                Case 6
  198.                    S = "RZ: " & js.rz
  199.                Case 7
  200.                    S = "Slider0: " & js.slider(0)
  201.                Case 8
  202.                    S = "Slider1: " & js.slider(1)
  203.       
  204.            End Select
  205.            lstJoyAxis.List(ListPos) = S
  206.            ListPos = ListPos + 1
  207.         
  208.         End If
  209.      Next
  210.     ' Buttons
  211.     For i = 0 To joyCaps.lButtons - 1
  212.         Select Case js.Buttons(i)
  213.         Case 0
  214.             lstButton.List(i) = "Button " + CStr(i + 1) + ": Up"
  215.             
  216.         Case Else
  217.             lstButton.List(i) = "Button " + CStr(i + 1) + ": Down"
  218.             
  219.         End Select
  220.     Next
  221.         
  222.      ' Hats
  223.     For i = 0 To joyCaps.lPOVs - 1
  224.         lstHat.List(i) = "POV " + CStr(i + 1) + ": " + CStr(js.POV(i))
  225.     Next
  226.     Me.Caption = "Joystick Sample: Available"
  227.     Exit Sub
  228. err_out:
  229.     MsgBox Err.Description & " : " & Err.Number, vbApplicationModal
  230.     End
  231. End Sub
  232. Private Sub Form_Load()
  233.     running = True
  234.     InitDirectInput
  235. End Sub
  236. Private Sub Form_Unload(cancel As Integer)
  237.    On Local Error Resume Next
  238.    If EventHandle <> 0 Then dx.DestroyEvent EventHandle
  239.    running = False
  240.    'Unacquire if we are holding a device
  241.    If Not diDev Is Nothing Then
  242.       diDev.Unacquire
  243.    End If
  244.    DoEvents
  245.    End
  246. End Sub
  247. Private Sub lstJoySticks_Click()
  248.     On Local Error Resume Next
  249.     Call CLRLISTS
  250.     'Unacquire the current device
  251.     'if we are holding a device
  252.     If Not diDev Is Nothing Then
  253.       diDev.Unacquire
  254.     End If
  255.     'Create the joystick device
  256.     Set diDev = Nothing
  257.     Set diDev = di.CreateDevice(diDevEnum.GetItem(lstJoySticks.ListIndex + 1).GetGuidInstance)
  258.     diDev.SetCommonDataFormat DIFORMAT_JOYSTICK
  259.     diDev.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
  260.     ' Find out what device objects it has
  261.     diDev.GetCapabilities joyCaps
  262.     Call IdentifyAxes(diDev)
  263.     ' Ask for notification of events
  264.     Call diDev.SetEventNotification(EventHandle)
  265.     ' Set deadzone for X and Y axis to 10 percent of the range of travel
  266.     With DiProp_Dead
  267.         .lData = 1000
  268.         .lHow = DIPH_BYOFFSET
  269.         
  270.         .lObj = DIJOFS_X
  271.         diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
  272.         
  273.         .lObj = DIJOFS_Y
  274.         diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
  275.         
  276.     End With
  277.     ' Set saturation zones for X and Y axis to 5 percent of the range
  278.     With DiProp_Saturation
  279.         .lData = 9500
  280.         .lHow = DIPH_BYOFFSET
  281.         
  282.         .lObj = DIJOFS_X
  283.          diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
  284.         
  285.         .lObj = DIJOFS_Y
  286.          diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
  287.          
  288.     End With
  289.     SetPropRange
  290.     diDev.Acquire
  291.     Me.Caption = "Joystick Sample: Querying Properties"
  292.     ' Get the list of current properties
  293.     ' USB joysticks wont call this callback until you play with the joystick
  294.     ' so we call the callback ourselves the first time
  295.     DirectXEvent8_DXCallback 0
  296.     ' Poll the device so that events are sure to be signaled.
  297.     ' Usually this would be done in Sub Main or in the game rendering loop.
  298.     While running = True
  299.         DoEvents
  300.         diDev.Poll
  301.     Wend
  302. End Sub
  303. Sub SetPropRange()
  304.     ' NOTE Some devices do not let you set the range
  305.     On Local Error Resume Next
  306.     ' Set range for all axes
  307.     With DiProp_Range
  308.         .lHow = DIPH_DEVICE
  309.         .lMin = 0
  310.         .lMax = 10000
  311.     End With
  312.     diDev.SetProperty "DIPROP_RANGE", DiProp_Range
  313. End Sub
  314. Sub CLRLISTS()
  315.     lstJoyAxis.Clear
  316.     lstButton.Clear
  317.     lstHat.Clear
  318. End Sub
  319. Sub IdentifyAxes(diDev As DirectInputDevice8)
  320.    ' It's not enough to count axes; we need to know which in particular
  321.    ' are present.
  322.    Dim didoEnum As DirectInputEnumDeviceObjects
  323.    Dim dido As DirectInputDeviceObjectInstance
  324.    Dim i As Integer
  325.    For i = 1 To 8
  326.      AxisPresent(i) = False
  327.    Next
  328.    ' Enumerate the axes
  329.    Set didoEnum = diDev.GetDeviceObjectsEnum(DIDFT_AXIS)
  330.    ' Check data offset of each axis to learn what it is
  331.    Dim sGuid As String
  332.    For i = 1 To didoEnum.GetCount
  333.      Set dido = didoEnum.GetItem(i)
  334.      
  335.          sGuid = dido.GetGuidType
  336.          Select Case sGuid
  337.             Case "GUID_XAxis"
  338.               AxisPresent(1) = True
  339.             Case "GUID_YAxis"
  340.               AxisPresent(2) = True
  341.             Case "GUID_ZAxis"
  342.               AxisPresent(3) = True
  343.             Case "GUID_RxAxis"
  344.               AxisPresent(4) = True
  345.             Case "GUID_RyAxis"
  346.               AxisPresent(5) = True
  347.             Case "GUID_RzAxis"
  348.               AxisPresent(6) = True
  349.             Case "GUID_Slider"
  350.                 AxisPresent(8) = True
  351.                 AxisPresent(7) = True
  352.          End Select
  353.    Next
  354. End Sub
  355.